home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / slib / schmooz.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  18.9 KB  |  629 lines
  1. ;;; "schmooz.scm" Program for extracting texinfo comments from Scheme.
  2. ;;; Copyright (C) 1998, 2000 Radey Shouman and Aubrey Jaffer.
  3. ;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. ;;$Header: /usr/local/cvsroot/slib/schmooz.scm,v 1.15 2000/05/17 22:09:06 jaffer Exp $
  21. ;;$Name:  $
  22.  
  23. ;;; REPORT an error or warning
  24. (define report
  25.   (lambda args
  26.     (display *scheme-source-name*)
  27.     (display ": In function `")
  28.     (display *procedure*)
  29.     (display "': ")
  30.     (newline)
  31.  
  32.     (display *derived-txi-name*)
  33.     (display ": ")
  34.     (display *output-line*)
  35.     (display ": warning: ")
  36.     (apply qreport args)))
  37.  
  38. (define qreport
  39.   (lambda args
  40.     (for-each (lambda (x) (write x) (display #\ )) args)
  41.     (newline)))
  42.  
  43. (require 'common-list-functions)    ;some
  44. (require 'string-search)
  45. (require 'fluid-let)
  46. (require 'line-i/o)            ;read-line
  47. (require 'filename)
  48. (require 'scanf)
  49. ;;(require 'debug) (set! *qp-width* 100) (define qreport qpn)
  50.  
  51. ;;; This allows us to test without generating files
  52. (define *scheme-source* (current-input-port))
  53. (define *scheme-source-name* "stdin")
  54. (define *derived-txi* (current-output-port))
  55. (define *derived-txi-name* "?")
  56.  
  57. (define *procedure* #f)
  58. (define *output-line* 0)
  59.  
  60. (define CONTLINE -80)
  61.  
  62. ;;; OUT indents and displays the arguments
  63. (define (out indent . args)
  64.   (cond ((>= indent 0)
  65.      (newline *derived-txi*)
  66.      (set! *output-line* (+ 1 *output-line*))
  67.      (do ((j indent (- j 8)))
  68.          ((> 8 j)
  69.           (do ((i j (- i 1)))
  70.           ((>= 0 i))
  71.         (display #\  *derived-txi*)))
  72.        (display #\     *derived-txi*))))
  73.   (for-each (lambda (a)
  74.           (cond ((symbol? a)
  75.              (display a *derived-txi*))
  76.             ((string? a)
  77.              (display a *derived-txi*)
  78. ;             (cond ((string-index a #\newline)
  79. ;                (set! *output-line* (+ 1 *output-line*))
  80. ;                (report "newline in string" a)))
  81.              )
  82.             (else
  83.              (display a *derived-txi*))))
  84.         args))
  85.  
  86. ;; LINE is a string, ISTRT the index in LINE at which to start.
  87. ;; Returns a list (next-char-number . list-of-tokens).
  88. ;; arguments look like:
  89. ;;    "(arg1 arg2)"  or "{arg1,arg2}" or the whole line is split
  90. ;; into whitespace separated tokens.
  91. (define (parse-args line istrt)
  92.   (define (tok1 istrt close sep? splice)
  93.     (let loop-args ((istrt istrt)
  94.             (args '()))
  95.       (let loop ((iend istrt))
  96.     (cond ((>= iend (string-length line))
  97.            (if close
  98.            (slib:error close "not found in" line)
  99.            (cons iend
  100.              (reverse
  101.               (if (> iend istrt)
  102.                   (cons (substring line istrt iend) args)
  103.                   args)))))
  104.           ((eqv? close (string-ref line iend))
  105.            (cons (+ iend 1)
  106.              (reverse (if (> iend istrt)
  107.                   (cons (substring line istrt iend) args)
  108.                   args))))
  109.           ((sep? (string-ref line iend))
  110.            (let ((arg (and (> iend istrt)
  111.                    (substring line istrt iend))))
  112.          (if (equal? arg splice)
  113.              (let ((rest (tok1 (+ iend 1) close sep? splice)))
  114.                (cons (car rest)
  115.                  (append args (cadr rest))))
  116.              (loop-args (+ iend 1)
  117.                 (if arg
  118.                     (cons arg args)
  119.                     args)))))
  120.           (else
  121.            (loop (+ iend 1)))))))
  122.   (let skip ((istrt istrt))
  123.     (cond ((>= istrt (string-length line)) (cons istrt '()))
  124.       ((char-whitespace? (string-ref line istrt))
  125.        (skip (+ istrt 1)))
  126.       ((eqv? #\{ (string-ref line istrt))
  127.        (tok1 (+ 1 istrt) #\} (lambda (c) (eqv? c #\,)) #f))
  128.       ((eqv? #\( (string-ref line istrt))
  129.        (tok1 (+ 1 istrt) #\) char-whitespace? "."))
  130.       (else
  131.        (tok1 istrt #f char-whitespace? #f)))))
  132.  
  133.  
  134. ;; Substitute @ macros in string LINE.
  135. ;; Returns a list, the first element is the substituted version
  136. ;; of LINE, the rest are lists beginning with '@dfn or '@args
  137. ;; and followed by the arguments that were passed to those macros.
  138. ;; MACS is an alist of (macro-name . macro-value) pairs.
  139. (define (substitute-macs line macs)
  140.   (define (get-word i)
  141.     (let loop ((j (+ i 1)))
  142.       (cond ((>= j (string-length line))
  143.          (substring line i j))
  144.         ((or (char-alphabetic? (string-ref line j))
  145.          (char-numeric? (string-ref line j)))
  146.          (loop (+ j 1)))
  147.         (else (substring line i j)))))
  148.   (let loop ((istrt 0)
  149.          (i 0)
  150.          (res '()))
  151.     (cond ((>= i (string-length line))
  152.        (list
  153.         (apply string-append
  154.            (reverse
  155.             (cons (substring line istrt (string-length line))
  156.               res)))))
  157.       ((char=? #\@ (string-ref line i))
  158.        (let* ((w (get-word i))
  159.           (symw (string->symbol w)))
  160.          (cond ((eq? '@cname symw)
  161.             (let ((args (parse-args
  162.                  line (+ i (string-length w)))))
  163.               (cond ((and args (= 2 (length args)))
  164.                  (loop (car args) (car args)
  165.                    (cons
  166.                     (string-append
  167.                      "@code{" (cadr args) "}")
  168.                     (cons (substring line istrt i) res))))
  169.                 (else
  170.                  (report "@cname wrong number of args" line)
  171.                  (loop istrt (+ i (string-length w)) res)))))
  172.            ((eq? '@dfn symw)
  173.             (let* ((args (parse-args
  174.                   line (+ i (string-length w))))
  175.                (inxt (car args))
  176.                (rest (loop inxt inxt
  177.                        (cons (substring line istrt inxt)
  178.                          res))))
  179.               (cons (car rest)
  180.                 (cons (cons '@dfn (cdr args))
  181.                   (cdr rest)))))
  182.            ((eq? '@args symw)
  183.             (let* ((args (parse-args
  184.                   line (+ i (string-length w))))
  185.                (inxt (car args))
  186.                (rest (loop inxt inxt res)))
  187.               (cons (car rest)
  188.                 (cons (cons '@args (cdr args))
  189.                   (cdr rest)))))
  190.            ((assq symw macs) =>
  191.             (lambda (s)
  192.               (loop (+ i (string-length w))
  193.                 (+ i (string-length w))
  194.                 (cons (cdr s)
  195.                   (cons (substring line istrt i) res)))))
  196.            (else (loop istrt (+ i (string-length w)) res)))))
  197.       (else (loop istrt (+ i 1) res)))))
  198.  
  199.  
  200. (define (sexp-def sexp)
  201.   (and (pair? sexp)
  202.        (memq (car sexp) '(DEFINE DEFVAR DEFCONST DEFINE-SYNTAX DEFMACRO))
  203.        (car sexp)))
  204.  
  205. (define def->var-name cadr)
  206.  
  207. (define (def->args sexp)
  208.   (define name (cadr sexp))
  209.   (define (body forms)
  210.     (if (pair? forms)
  211.     (if (null? (cdr forms))
  212.         (form (car forms))
  213.         (body (cdr forms)))
  214.     #f))
  215.   (define (form sexp)
  216.     (if (pair? sexp)
  217.     (case (car sexp)
  218.       ((LAMBDA) (cons name (cadr sexp)))
  219.       ((BEGIN) (body (cdr sexp)))
  220.       ((LET LET* LETREC)
  221.        (if (or (null? (cadr sexp))
  222.            (pair? (cadr sexp)))
  223.            (body (cddr sexp))
  224.            (body (cdddr sexp))))    ;named LET
  225.       (else #f))
  226.     #f))
  227.   (case (car sexp)
  228.     ((DEFINE) (if (pair? name)
  229.           name
  230.           (form (caddr sexp))))
  231.     ((DEFINE-SYNTAX) '())
  232.     ((DEFMACRO) (cons (cadr sexp) (caddr sexp)))
  233.     ((DEFVAR DEFCONST) #f)
  234.     (else (slib:error 'schmooz "doesn't look like definition" sexp))))
  235.  
  236. ;; Generate alist of argument macro definitions.
  237. ;; If ARGS is a symbol or string, then the definitions will be used in a
  238. ;; `defvar', if ARGS is a (possibly improper) list, they will be used in
  239. ;; a `defun'.
  240. (define (scheme-args->macros args)
  241.   (define (arg->string a)
  242.     (if (string? a) a (symbol->string a)))
  243.   (define (arg->macros arg i)
  244.     (let ((s (number->string i))
  245.       (m (string-append "@var{" (arg->string arg) "}")))
  246.       (list (cons (string->symbol (string-append "@" s)) m)
  247.         (cons (string->symbol (string-append "@arg" s)) m))))
  248.   (let* ((fun? (pair? args))
  249.      (arg0 (if fun? (car args) args))
  250.      (args (if fun? (cdr args) '())))
  251.     (let ((m0 (string-append
  252.            (if fun? "@code{" "@var{") (arg->string arg0) "}")))
  253.       (append
  254.        (list (cons '@arg0 m0) (cons '@0 m0))
  255.        (let recur ((i 1)
  256.            (args args))
  257.      (cond ((null? args) '())
  258.            ((or (symbol? args)        ;Rest list
  259.             (string? args))
  260.         (arg->macros args i))
  261.            (else
  262.         (append (arg->macros (car args) i)
  263.             (recur (+ i 1) (cdr args))))))))))
  264.  
  265. ;; Extra processing to be done for @dfn
  266. (define (out-cindex arg)
  267.   (out 0 "@cindex " arg))
  268.  
  269. ;; ARGS looks like the cadr of a function definition:
  270. ;; (fun-name arg1 arg2 ...)
  271. (define (schmooz-fun defop args body xdefs)
  272.   (define (out-header args op)
  273.     (let ((fun (car args))
  274.       (args (cdr args)))
  275.       (out 0 #\@ op #\space fun)
  276.       (let loop ((args args))
  277.     (cond ((null? args))
  278.           ((symbol? args)
  279.            (loop (symbol->string args)))
  280.           ((string? args)
  281.            (out CONTLINE " "
  282.             (let ((n (- (string-length args) 1)))
  283.               (if (eqv? #\s (string-ref args n))
  284.               (substring args 0 n)
  285.               args))
  286.             " @dots{}"))
  287.           ((pair? args)
  288.            (out CONTLINE " "
  289.             (if (or (eq? '... (car args))
  290.                 (equal? "..." (car args)))
  291.             "@dots{}"
  292.             (car args)))
  293.            (loop (cdr args)))
  294.           (else (slib:error 'schmooz-fun args))))))
  295.   (let* ((mac-list (scheme-args->macros args))
  296.      (ops (case defop
  297.            ((DEFINE-SYNTAX) '("defspec" . "defspecx"))
  298.            ((DEFMACRO) '("defmac" . "defmacx"))
  299.            (else '("defun" . "defunx")))))
  300.     (out-header args (car ops))
  301.     (let loop ((xdefs xdefs))
  302.       (cond ((pair? xdefs)
  303.          (out-header (car xdefs) (cdr ops))
  304.          (loop (cdr xdefs)))))
  305.     (for-each (lambda (subl)
  306.         (out 0 (car subl))
  307.         (for-each (lambda (l)
  308.                 (case (car l)
  309.                   ((@dfn)
  310.                    (out-cindex (cadr l)))
  311.                   ((@args)
  312.                    (out-header
  313.                 (cons (car args) (cdr l))
  314.                 (cdr ops)))))
  315.               (cdr subl)))
  316.           (map (lambda (bl)
  317.              (substitute-macs bl mac-list))
  318.            body))
  319.     (out 0 "@end " (car ops))
  320.     (out 0)))
  321.  
  322. (define (schmooz-var defop name body xdefs)
  323.   (let* ((mac-list (scheme-args->macros name)))
  324.     (out 0 "@defvar " name)
  325.     (let loop ((xdefs xdefs))
  326.       (cond ((pair? xdefs)
  327.          (out 0 "@defvarx " (car xdefs))
  328.          (loop (cdr xdefs)))))
  329.     (for-each (lambda (subl)
  330.         (out 0 (car subl))
  331.         (for-each (lambda (l)
  332.                 (case (car l)
  333.                   ((@dfn) (out-cindex (cadr l)))
  334.                   (else
  335.                    (report "bad macro" l))))
  336.               (cdr subl)))
  337.           (map (lambda (bl)
  338.              (substitute-macs bl mac-list))
  339.            body))
  340.     (out 0 "@end defvar")
  341.     (out 0)))
  342.  
  343. ;;; SCHMOOZ files.
  344. (define schmooz
  345.   (let* ((scheme-file? (filename:match-ci?? "*??scm"))
  346.      (txi-file? (filename:match-ci?? "*??txi"))
  347.      (texi-file? (let ((tex? (filename:match-ci?? "*??tex"))
  348.                (texi? (filename:match-ci?? "*??texi")))
  349.                (lambda (filename) (or (txi-file? filename)
  350.                           (tex? filename)
  351.                           (texi? filename)))))
  352.      (txi->scm (filename:substitute?? "*txi" "*scm"))
  353.      (scm->txi (filename:substitute?? "*scm" "*txi")))
  354.     (define (schmooz-texi-file file)
  355.       (call-with-input-file file
  356.     (lambda (port)
  357.       (do ((pos (find-string-from-port? "@include" port)
  358.             (find-string-from-port? "@include" port)))
  359.           ((not pos))
  360.         (let ((fname #f))
  361.           (cond ((not (eqv? 1 (fscanf port " %s" fname))))
  362.             ((not (txi-file? fname)))
  363.             ((not (file-exists? (txi->scm fname))))
  364.             (else (schmooz (txi->scm fname)))))))))
  365.     (define (schmooz-scm-file file txi-name)
  366.       (display "Schmoozing ") (write file)
  367.       (display " -> ") (write txi-name) (newline)
  368.       (fluid-let ((*scheme-source* (open-input-file file))
  369.           (*scheme-source-name* file)
  370.           (*derived-txi* (open-output-file txi-name))
  371.           (*derived-txi-name* txi-name))
  372.     (set! *output-line* 1)
  373.     (cond ((scheme-file? file))
  374.           (else (find-string-from-port? ";" *scheme-source* #\;)
  375.             (read-line *scheme-source*)))
  376.     (schmooz-tops schmooz-top)
  377.     (close-input-port *scheme-source*)
  378.     (close-output-port *derived-txi*)))
  379.     (lambda files
  380.       (for-each (lambda (file)
  381.           (define sl (string-length file))
  382.           (cond ((texi-file? file) (schmooz-texi-file file))
  383.             ((scheme-file? file)
  384.              (schmooz-scm-file file (scm->txi file)))
  385.             (else (schmooz-scm-file
  386.                    file (string-append file ".txi")))))
  387.         files))))
  388.  
  389. ;;; SCHMOOZ-TOPS - schmooz top level forms.
  390. (define (schmooz-tops schmooz-top)
  391.   (let ((doc-lines '())
  392.     (doc-args #f))
  393.     (define (skip-ws line istrt)
  394.       (do ((i istrt (+ i 1)))
  395.       ((or (>= i (string-length line))
  396.            (not (memv (string-ref line i)
  397.               '(#\space #\tab #\;))))
  398.        (substring line i (string-length line)))))
  399.  
  400.     (define (tok1 line)
  401.       (let loop ((i 0))
  402.     (cond ((>= i (string-length line)) line)
  403.           ((or (char-whitespace? (string-ref line i))
  404.            (memv (string-ref line i) '(#\; #\( #\{)))
  405.            (substring line 0 i))
  406.           (else (loop (+ i 1))))))
  407.  
  408.     (define (read-cmt-line)
  409.       (cond ((eqv? #\; (peek-char *scheme-source*))
  410.          (read-char *scheme-source*)
  411.          (read-cmt-line))
  412.         (else (read-line *scheme-source*))))
  413.  
  414.     (define (read-meta-cmt)
  415.       (let skip ((metarg? #f))
  416.     (let ((c (read-char *scheme-source*)))
  417.       (case c
  418.         ((#\newline) (if metarg? (skip #t)))
  419.         ((#\\) (skip #t))
  420.         ((#\!) (cond ((eqv? #\# (peek-char *scheme-source*))
  421.               (read-char *scheme-source*)
  422.               (if #f #f))
  423.              (else
  424.               (skip metarg?))))
  425.         (else 
  426.          (if (char? c) (skip metarg?) c))))))
  427.  
  428.     (define (lp c)
  429.       (cond ((eof-object? c)
  430.          (cond ((pair? doc-lines)
  431.             (report "No definition found for @body doc lines"
  432.                 (reverse doc-lines)))))
  433.         ((eqv? c #\newline)
  434.          (read-char *scheme-source*)
  435.          (set! *output-line* (+ 1 *output-line*))
  436.          ;;(newline *derived-txi*)
  437.          (lp (peek-char *scheme-source*)))
  438.         ((char-whitespace? c)
  439.          (write-char (read-char *scheme-source*) *derived-txi*)
  440.          (lp (peek-char *scheme-source*)))
  441.         ((char=? c #\;)
  442.          (c-cmt c))
  443.         ((char=? c #\#)
  444.          (read-char *scheme-source*)
  445.          (if (eqv? #\! (peek-char *scheme-source*))
  446.          (read-meta-cmt)
  447.          (report "misread sharp object" (peek-char *scheme-source*)))
  448.          (lp (peek-char *scheme-source*)))
  449.         (else
  450.          (sx))))
  451.  
  452.     (define (sx)
  453.       (let* ((s1 (read *scheme-source*))
  454.          ;;Read all forms separated only by single newlines
  455.          ;;and trailing whitespace.
  456.          (ss (let recur ()
  457.            (let ((c (peek-char *scheme-source*)))
  458.              (cond ((eqv? c #\newline)
  459.                 (read-char *scheme-source*)
  460.                 (if (eqv? #\( (peek-char *scheme-source*))
  461.                 (let ((s (read *scheme-source*)))
  462.                   (cons s (recur)))
  463.                 '()))
  464.                ((char-whitespace? c)
  465.                 (read-char *scheme-source*)
  466.                 (recur))
  467.                (else '()))))))
  468.     (cond ((eof-object? s1))
  469.           (else
  470.            (schmooz-top s1 ss (reverse doc-lines) doc-args)
  471.            (set! doc-lines '())
  472.            (set! doc-args #f)
  473.            (lp (peek-char *scheme-source*))))))
  474.  
  475.     (define (out-cmt line)
  476.       (let ((subl (substitute-macs line '())))
  477.     (display (car subl) *derived-txi*)
  478.     (for-each
  479.      (lambda (l)
  480.        (case (car l)
  481.          ((@dfn)
  482.           (out-cindex (cadr l)))
  483.          (else
  484.           (report "bad macro" line))))
  485.      (cdr subl))
  486.     (newline *derived-txi*)))
  487.  
  488.     ;;Comments not transcribed to generated Texinfo files.
  489.     (define (c-cmt c)
  490.       (cond ((eof-object? c) (lp c))
  491.         ((eqv? #\; c)
  492.          (read-char *scheme-source*)
  493.          (c-cmt (peek-char *scheme-source*)))
  494.         ;; Escape to start Texinfo comments
  495.         ((eqv? #\@ c)
  496.          (let* ((line (read-line *scheme-source*))
  497.             (tok (tok1 line)))
  498.            (cond ((or (string=? tok "@body")
  499.               (string=? tok "@text"))
  500.               (set! doc-lines
  501.                 (cons (skip-ws line (string-length tok))
  502.                   doc-lines))
  503.               (body-cmt (peek-char *scheme-source*)))
  504.              ((string=? tok "@args")
  505.               (let ((args
  506.                  (parse-args line (string-length tok))))
  507.             (set! doc-args (cdr args))
  508.             (set! doc-lines
  509.                   (cons (skip-ws line (car args))
  510.                     doc-lines)))
  511.               (body-cmt (peek-char *scheme-source*)))
  512.              (else
  513.               (out-cmt (if (string=? tok "@")
  514.                    (skip-ws line 1)
  515.                    line))
  516.               (doc-cmt (peek-char *scheme-source*))))))
  517.         ;; Transcribe the comment line to C source file.
  518.         (else
  519.          (read-line *scheme-source*)
  520.          (lp (peek-char *scheme-source*)))))
  521.  
  522.     ;;Comments incorporated in generated Texinfo files.
  523.     ;;Continue adding lines to DOC-LINES until a non-comment
  524.     ;;line is reached (may be a blank line).
  525.     (define (body-cmt c)
  526.       (cond ((eof-object? c) (lp c))
  527.         ((eqv? #\; c)
  528.          (set! doc-lines (cons (read-cmt-line) doc-lines))
  529.          (body-cmt (peek-char *scheme-source*)))
  530.         ((eqv? c #\newline)
  531.          (read-char *scheme-source*)
  532.          (lp (peek-char *scheme-source*)))
  533.         ;; Allow whitespace before ; in doc comments.
  534.         ((char-whitespace? c)
  535.          (read-char *scheme-source*)
  536.          (body-cmt (peek-char *scheme-source*)))
  537.         (else
  538.          (lp (peek-char *scheme-source*)))))
  539.  
  540.     ;;Comments incorporated in generated Texinfo files.
  541.     ;;Transcribe comments to current position in Texinfo file
  542.     ;;until a non-comment line is reached (may be a blank line).
  543.     (define (doc-cmt c)
  544.       (cond ((eof-object? c) (lp c))
  545.         ((eqv? #\; c)
  546.          (out-cmt (read-cmt-line))
  547.          (doc-cmt (peek-char *scheme-source*)))
  548.         ((eqv? c #\newline)
  549.          (read-char *scheme-source*)
  550.          (newline *derived-txi*)
  551.          (lp (peek-char *scheme-source*)))
  552.         ;; Allow whitespace before ; in doc comments.
  553.         ((char-whitespace? c)
  554.          (read-char *scheme-source*)
  555.          (doc-cmt (peek-char *scheme-source*)))
  556.         (else
  557.          (newline *derived-txi*)
  558.          (lp (peek-char *scheme-source*)))))
  559.     (lp (peek-char *scheme-source*))))
  560.  
  561. (define (schmooz-top-doc-begin def1 defs doc proc-args)
  562.   (let ((op1 (sexp-def def1)))
  563.     (cond
  564.      ((not op1)
  565.       (or (null? doc)
  566.       (report "SCHMOOZ: no definition found for Texinfo documentation"
  567.           doc (car defs))))
  568.      (else
  569.       (let* ((args (def->args def1))
  570.          (args (if proc-args
  571.                (cons (if args (car args) (def->var-name def1))
  572.                  proc-args)
  573.                args)))
  574.     (let loop ((ss defs)
  575.            (smatch (list (or args (def->var-name def1)))))
  576.       (if (null? ss)
  577.           (let ((smatch (reverse smatch)))
  578.         ((if args schmooz-fun schmooz-var)
  579.             op1 (car smatch) doc (cdr smatch)))
  580.           (if (eq? op1 (sexp-def (car ss)))
  581.           (let ((a (def->args (car ss))))
  582.             (loop (cdr ss)
  583.               (if args
  584.                   (if a
  585.                   (cons a smatch)
  586.                   smatch)
  587.                   (if a
  588.                   smatch
  589.                   (cons (def->var-name (car ss))
  590.                     smatch)))))))))))))
  591.  
  592. ;;; SCHMOOZ-TOP - schmooz top level form sexp.
  593. (define (schmooz-top sexp1 sexps doc proc-args)
  594.   (cond ((not (pair? sexp1)))
  595.     ((pair? sexps)
  596.      (if (pair? doc)
  597.          (schmooz-top-doc-begin sexp1 sexps doc proc-args))
  598.      (set! doc '()))
  599.     (else
  600.      (case (car sexp1)
  601.        ((LOAD REQUIRE)        ;If you redefine load, you lose
  602.         #f)
  603.        ((BEGIN)
  604.         (schmooz-top (cadr sexp1) '() doc proc-args)
  605.         (set! doc '())
  606.         (for-each (lambda (s)
  607.             (schmooz-top s '() doc #f))
  608.               (cddr sexp1)))
  609.        ((DEFVAR DEFINE DEFCONST DEFINE-SYNTAX DEFMACRO)
  610.         (let* ((args (def->args sexp1))
  611.            (args (if proc-args
  612.                  (cons (if args (car args) (cadr sexp1))
  613.                    proc-args)
  614.                  args)))
  615.           (cond (args
  616.              (set! *procedure* (car args))
  617.              (cond ((pair? doc)
  618.                 (schmooz-fun (car sexp1) args doc '())
  619.                 (set! doc '()))))
  620.             (else
  621.              (cond ((pair? doc)
  622.                 (schmooz-var (car sexp1) (cadr sexp1) doc '())
  623.                 (set! doc '()))))))))))
  624.   (or (null? doc)
  625.       (report
  626.        "SCHMOOZ: no definition found for Texinfo documentation"
  627.        doc sexp))
  628.   (set! *procedure* #f))
  629.